home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power Programmierung
/
Power-Programmierung (Tewi)(1994).iso
/
magazine
/
aijournl
/
1986_09
/
expert2.ltg
< prev
next >
Wrap
Text File
|
1986-10-30
|
3KB
|
128 lines
Listing 2.
Lisp source code for the ATN-to-Lisp compiler.
;;; ATN Compiler. Copyright Jonathan Amsterdam, 1986. All Rights
;;; Reserved.
;;; These two functions are the meat of the compiler. See the text for
;;; details.
(DEFMACRO DEFNODE (NAME &REST ARCS)
`(DEFUN ,NAME (WORD-LIST REG-ALIST)
(LET ((*WORD* (CAR WORD-LIST)))
(OR
,@(MAPCAR #'COMPILE-ARC ARCS)))))
(DEFUN COMPILE-ARC (ARC)
(LET ((NAME (ARC-NAME ARC))
(TEST (ARC-TEST ARC))
(DESTINATION (ARC-DESTINATION ARC))
(ACTIONS (ARC-ACTIONS ARC)))
(CASE (ARC-TYPE ARC)
(WRD
(LET ((WORDS (IF (LISTP NAME) NAME (LIST NAME))))
`(LET ((NEW-REG-ALIST REG-ALIST))
(COND ((AND (MEMBER *WORD* ',WORDS) ,TEST)
,@ACTIONS
(,DESTINATION (CDR WORD-LIST) NEW-REG-ALIST))))))
(CAT
`(LET ((NEW-REG-ALIST REG-ALIST))
(COND ((AND (EQ (GET *WORD* 'CAT) ',NAME) ,TEST)
,@ACTIONS
(,DESTINATION (CDR WORD-LIST) NEW-REG-ALIST)))))
(TEST
`(LET ((NEW-REG-ALIST REG-ALIST))
(COND (,TEST
,@ACTIONS
(,DESTINATION (CDR WORD-LIST) NEW-REG-ALIST)))))
(PUSH
`(LET ((RESULT (,NAME WORD-LIST NIL)))
(LET ((*VALUE* (RESULT-VALUE RESULT))
(NEW-REG-ALIST REG-ALIST))
(COND ((AND *VALUE* ,TEST)
,@ACTIONS
(,DESTINATION (RESULT-WORD-LIST RESULT) NEW-REG-ALIST))))))
(POP
`(LET ((NEW-REG-ALIST REG-ALIST))
(COND (,TEST
(CONS ,NAME WORD-LIST)))))
(JUMP
`(LET ((NEW-REG-ALIST REG-ALIST))
(COND (,TEST
,@ACTIONS
(,DESTINATION WORD-LIST NEW-REG-ALIST))))))))
;;; Actions on registers.
(DEFMACRO SETR (REG-NAME VALUE)
`(SETQ NEW-REG-ALIST (CONS (CONS ',REG-NAME ,VALUE) NEW-REG-ALIST)))
(DEFMACRO GETR (REG-NAME)
`(CDR (ASSOC ',REG-NAME NEW-REG-ALIST)))
;;; This macro is useful for putting properties on symbols.
(DEFMACRO WORD (NAME &REST FEATURES)
(WORD-FEATURES NAME FEATURES))
(DEFUN WORD-FEATURES (NAME FEATURES)
(DOLIST (FEATURE FEATURES)
(PUTPROP NAME (CADR FEATURE) (CAR FEATURE))))
;;; The remaining definitions are support functions for the compiler.
(DEFUN ARC-TYPE (ARC)
(FIRST ARC))
(DEFUN ARC-NAME (ARC)
(SECOND ARC))
(DEFUN ARC-TEST (ARC)
(IF (EQ (ARC-TYPE ARC) 'TEST)
(SECOND ARC)
(THIRD ARC)))
(DEFUN ARC-DESTINATION (ARC)
(COND
((EQ (ARC-TYPE ARC) 'JUMP)
(SECOND ARC))
((EQ (ARC-TYPE ARC) 'TEST)
(THIRD ARC))
(T
(FOURTH ARC))))
(DEFUN ARC-ACTIONS (ARC)
(IF (MEMBER (ARC-TYPE ARC) '(JUMP TEST))
(CDDDR ARC)
(CDDDDR ARC)))
(DEFUN RESULT-VALUE (RESULT)
(CAR RESULT))
(DEFUN RESULT-WORD-LIST (RESULT)
(CDR RESULT))
<*>End of file<*>
Time remaining = 69 min.
========================== FILE MENU ==========================
D)ownload a file H)elp L)ist files N)ew files
U)pload a file ?) Xfer info
More (Y),N,NS? n
File Function <D,G,H,L,N,Q,U,?>? g
It is now 4:38 PM.
You have been on for 3 Min. and 5 Sec.
Thanks for calling, SUSAN!
Z